home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / fildfs.lisp < prev    next >
Text File  |  1993-07-17  |  12KB  |  308 lines
  1. ;-*- mode:lisp; package:boxer ;base: 8; fonts:cptfont -*-
  2.  
  3. ;;; Macro Definitions and Variable Declarations for the BOXER File system
  4. ;;;
  5. ;;; (C) Copyright 1984 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; Permission to use, copy, modify, distribute, and sell this software
  8. ;;; and its documentation for any purpose is hereby granted without fee,
  9. ;;; provided that the above copyright notice appear in all copies and that
  10. ;;; both that copyright notice and this permission notice appear in
  11. ;;; supporting documentation, and that the name of M.I.T. not be used in
  12. ;;; advertising or publicity pertaining to distribution of the software
  13. ;;; without specific, written prior permission.  M.I.T. makes no
  14. ;;; representations about the suitability of this software for any
  15. ;;; purpose.  It is provided "as is" without express or implied warranty.
  16. ;;;
  17. ;;;
  18. ;;;                          +-Data--+
  19. ;;; This file is part of the | BOXER | system.
  20. ;;;                          +-------+
  21. ;;;
  22.  
  23. ;*********************************************************************************************
  24. ;*                              TOP  LEVEL  DEFINITIONS                                      *
  25. ;*********************************************************************************************
  26.  
  27. ;;;Pathname Construction and manipulation...
  28.  
  29. (FS:DEFINE-CANONICAL-TYPE :BOX "Box"    ;default type for SAVE/READ
  30.           (:TOPS-20 "Box")
  31.           (:VMS "Box")
  32.           (:ITS "Box"))
  33.  
  34. (defprop :box 16. :binary-file-byte-size)
  35.  
  36.  
  37. ;;initializations...
  38.  
  39. (DEFVAR *BOXER-PATHNAME-DEFAULT* (TELL (FS:DEFAULT-PATHNAME) :NEW-CANONICAL-TYPE ':BOX)
  40.   "Default pathname for saving boxer files")
  41.  
  42. (DEFVAR *INIT-FILE-SPECIFIER* (FS:MERGE-PATHNAMES "boxer.init" *BOXER-PATHNAME-DEFAULT*)
  43.   "The default name of the initial Boxer world load. ")
  44.  
  45. (DEFVAR *STICKY-FILE-DEFAULTING?* T
  46.   "A switch to make the default filename the last pathname that was used. ")
  47.  
  48. (SETQ *FILE-PORT-HASH-TABLE* (MAKE-HASH-TABLE))
  49.  
  50. (DEFVAR *ROW-CHAS-POINTER-ADJUST* NIL
  51.   "A flag which the newly constructed row checks to see if it should forward pointers
  52.    to its chas. A Kludge until I write the fasdumper. ")
  53.  
  54. (DEFVAR *FASDUMP?* T)                ;use the fasdumper or not ?
  55.  
  56. (DEFVAR *BIT-ARRAYS-ARE-ROW-MAJOR-ORDERED?* #+LMITI NIL #-LMITI T)
  57.  
  58. ;;; BINARY file format...
  59. ;;; Commands are in the form of 16. bit numbers (apparently the max size for file streams)
  60. ;;; The top four bits in a command make up a limited number of immediate op-codes in which
  61. ;;; the next 12. bits make up an immediate argument to the first op-code
  62. ;;; the four bit box command code escapes to more specific box commands and 
  63. ;;; another four bit sequence escapes to general commands in the next word
  64.  
  65. ;*********************************************************************************************
  66. ;*                                    DEFINITIONS                                            *
  67. ;*********************************************************************************************
  68.  
  69.  
  70. ;;; Opcode definitions
  71. (DEFCONST %%BIN-OP-HIGH 1404)
  72. (DEFCONST %%BIN-OP-LOW 0014)
  73.  
  74. (DEFCONST %%BIN-OP-IM-ARG-SIZE (^ 2 12.))
  75. (DEFCONST %%BIN-OP-ARG-SIZE (^ 2 16.))
  76.  
  77. ;;; Currently supported version number
  78. (DEFCONST *VERSION-NUMBER* 3)
  79.  
  80. ;;; Dumping variables
  81.  
  82. (DEFVAR *BIN-DUMP-TABLE*)
  83. (DEFVAR *BIN-DUMP-INDEX*)
  84. (DEFVAR *BIN-DUMP-PACKAGE*)
  85. (DEFVAR *OUTERMOST-DUMPING-BOX* NIL
  86.   "The top level box which is being dumped. ")
  87. (DEFVAR *RESTORE-TURTLE-STATE* NIL
  88.   "Determines if the state of turtle boxes should be saved. ")
  89.  
  90. (DEFRESOURCE DUMP-HASH-TABLE ()
  91.   :CONSTRUCTOR (MAKE-INSTANCE 'SI:EQ-HASH-TABLE)
  92.   :INITIAL-COPIES 0)
  93.  
  94. (DEFMACRO MAKE-BIN-OP-DISPATCH-TABLE ()
  95.   `(MAKE-ARRAY 100))
  96.  
  97. (DEFMACRO BIN-OP-DISPATCH (TABLE NUMBER)
  98.   `(AREF ,TABLE ,NUMBER))
  99.  
  100. (DEFMACRO STORE-BIN-OP-DISPATCH (VALUE TABLE NUMBER)
  101.   `(ASET ,VALUE ,TABLE ,NUMBER))
  102.  
  103. (DEFPROP BIN-OP-DISPATCH
  104.      ((BIN-OP-DISPATCH TABLE NUMBER) . (STORE-BIN-OP-DISPATCH SI:VAL TABLE NUMBER))
  105.      SETF)
  106.  
  107. ;; so we can get the commands from their number format and vice versa
  108. (DEFVAR *BIN-OP-COMMAND-NAME-TABLE* (MAKE-BIN-OP-DISPATCH-TABLE))
  109.  
  110. (DEFMACRO DEFINE-BIN-OP (NAME VALUE INDEX)
  111.   `(PROGN 'COMPILE
  112.      (DEFCONST ,NAME ,VALUE)
  113.      (SETF (BIN-OP-DISPATCH *BIN-OP-COMMAND-NAME-TABLE* ,INDEX) ',NAME)))
  114.  
  115. (DEFUN DECODE-BIN-OP (BIN-OP-NUMBER)
  116.   (AREF *BIN-OP-COMMAND-NAME-TABLE* BIN-OP-NUMBER))
  117.  
  118.  
  119.  
  120. ;;; immediate commands.  The meaning of the 20 bit arg is specified in the comment
  121. (DEFMACRO DEFINE-IMMEDIATE-BIN-OP (NAME VALUE)
  122.   `(DEFINE-BIN-OP ,NAME ,VALUE ,VALUE))
  123.  
  124. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-NUMBER-IMMEDIATE 0)    ;<number>
  125. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-TABLE-FETCH-IMMEDIATE 1)    ;<table address>
  126. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-CHA-IMMEDIATE 2)    ;<character number>
  127. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-BOX-IMMEDIATE 3)    ;<box type>
  128. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-STRING-IMMEDIATE 4)     ;<string length>
  129. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-LIST-IMMEDIATE 5)    ;<list length>
  130. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-ARRAY 6)            ;number of options
  131. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-ROW-IMMEDIATE 7)    ;number of chas
  132. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-NAME-AND-INPUT-ROW-IMMEDIATE 10)    ;number of chas
  133. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-NAME-ROW-IMMEDIATE 11)
  134. (DEFINE-IMMEDIATE-BIN-OP BIN-OP-COMMAND-IMMEDIATE 17)    ;<command>
  135.  
  136. ;;; specific box commands
  137. (DEFMACRO DEFINE-BOX-BIN-OP (NAME VALUE)
  138.   `(DEFINE-BIN-OP ,NAME ,(DPB BIN-OP-BOX-IMMEDIATE %%BIN-OP-HIGH VALUE) ,VALUE))
  139.  
  140. (DEFINE-BOX-BIN-OP BIN-OP-DOIT-BOX 20)
  141. (DEFINE-BOX-BIN-OP BIN-OP-DATA-BOX 21)
  142. (DEFINE-BOX-BIN-OP BIN-OP-PORT-BOX 22)
  143. (DEFINE-BOX-BIN-OP BIN-OP-GRAPHICS-BOX 23)
  144. (DEFINE-BOX-BIN-OP BIN-OP-TURTLE-BOX 24)    ;without turtle state
  145. (DEFINE-BOX-BIN-OP BIN-OP-TURTLE-BOX* 25)    ;with turtle state, including bit array
  146. (DEFINE-BOX-BIN-OP BIN-OP-LL-BOX 26)
  147. (define-box-bin-op bin-op-graphics-data-box 31)
  148. (define-box-bin-op bin-op-sprite-box 32)
  149. ;; for compatibility with pre version 4.0 files
  150. (DEFINE-BOX-BIN-OP BIN-OP-LL-BOX-PRESCENCE-MARKER 27)
  151.  
  152. ;;; Other commands
  153. (DEFMACRO DEFINE-COMMAND-BIN-OP (NAME VALUE)
  154.   `(DEFINE-BIN-OP ,NAME ,(DPB BIN-OP-COMMAND-IMMEDIATE %%BIN-OP-HIGH VALUE) ,VALUE))
  155.  
  156. (DEFINE-COMMAND-BIN-OP BIN-OP-TABLE-FETCH 35)
  157. (DEFINE-COMMAND-BIN-OP BIN-OP-END-OF-BOX 36)
  158. (DEFINE-COMMAND-BIN-OP BIN-OP-STRING 37)
  159. (DEFINE-COMMAND-BIN-OP BIN-OP-SYMBOL 40)
  160. (DEFINE-COMMAND-BIN-OP BIN-OP-PACKAGE-SYMBOL 41)
  161.  
  162. (DEFINE-COMMAND-BIN-OP BIN-OP-POSITIVE-FIXNUM 42)
  163. (DEFINE-COMMAND-BIN-OP BIN-OP-NEGATIVE-FIXNUM 43)
  164. (DEFINE-COMMAND-BIN-OP BIN-OP-POSITIVE-FLOAT 44)
  165. (DEFINE-COMMAND-BIN-OP BIN-OP-NEGATIVE-FLOAT 45)
  166.  
  167. (DEFINE-COMMAND-BIN-OP BIN-OP-ROW 46)
  168. (DEFINE-COMMAND-BIN-OP BIN-OP-LIST 47)
  169.  
  170. (DEFINE-COMMAND-BIN-OP BIN-OP-INITIALIZE-AND-RETURN-ARRAY 50)
  171. (DEFINE-COMMAND-BIN-OP BIN-OP-INITIALIZE-AND-RETURN-NUMERIC-ARRAY 51)
  172.  
  173. (DEFINE-COMMAND-BIN-OP BIN-OP-FORMAT-VERSION 52)
  174. (DEFINE-COMMAND-BIN-OP BIN-OP-EOF 53)
  175.  
  176. (DEFINE-COMMAND-BIN-OP BIN-OP-FILE-PROPERTY-LIST 54)
  177.  
  178. (DEFINE-COMMAND-BIN-OP BIN-OP-TABLE-STORE 55)
  179.  
  180. (DEFINE-COMMAND-BIN-OP BIN-OP-SIMPLE-CONS 56)
  181. (DEFINE-COMMAND-BIN-OP BIN-OP-NAME-AND-INPUT-ROW 57)
  182. (DEFINE-COMMAND-BIN-OP BIN-OP-NAME-ROW 60)
  183.  
  184. ;;graphics stuff
  185. (DEFINE-COMMAND-BIN-OP BIN-OP-GRAPHICS-SHEET 61)
  186. (DEFINE-COMMAND-BIN-OP BIN-OP-GRAPHICS-OBJECT 62)
  187. (define-command-bin-op bin-op-turtle 63)
  188.  
  189.  
  190. (DEFMACRO WRITING-BIN-FILE ((BOX STREAM FILE) &BODY BODY)
  191.   `(WITH-OPEN-FILE (,STREAM ,FILE ':DIRECTION ':OUTPUT ':CHARACTERS NIL)
  192.      (USING-RESOURCE (*BIN-DUMP-TABLE* DUMP-HASH-TABLE)
  193.        (START-BIN-FILE ,STREAM)
  194.        (LET ((*BIN-DUMP-INDEX* 0)
  195.          (*BIN-DUMP-PACKAGE* PACKAGE)
  196.          (*OUTERMOST-DUMPING-BOX* ,BOX))
  197.      ,@BODY))
  198.      (END-BIN-FILE ,STREAM)))
  199.  
  200. ;*********************************************************************************************
  201. ;*                                LOADING   DEFINITIONS                                      *
  202. ;*********************************************************************************************
  203.  
  204. ;;; Loading variables
  205. (DEFRESOURCE BIN-LOAD-TABLE ()
  206.   :CONSTRUCTOR (MAKE-ARRAY 1000))
  207.  
  208. (DEFVAR *NO-VALUE-MARKER* (NCONS 'NO-VALUE))
  209. (DEFVAR *BIN-NEXT-COMMAND-FUNCTION*)
  210.  
  211. (DEFVAR *BIN-LOAD-TABLE*)
  212. (DEFVAR *BIN-LOAD-INDEX*)
  213. (DEFVAR *LOAD-PACKAGE*)
  214. (DEFVAR *FILE-BIN-VERSION*)
  215. (DEFVAR *ROW-MAJOR-ORDER?* T
  216.   "Specifies how bit-arrays were dumped out. The default is T due to existence of many
  217.    old files which were dumped out in zippy lisp")
  218.  
  219. (DEFVAR *BIN-OP-LOAD-COMMAND-TABLE* (MAKE-BIN-OP-DISPATCH-TABLE))
  220.  
  221. (DEFVAR *SUPPORTED-OBSOLETE-VERSIONS* '(1. 2.))
  222.  
  223. (DEFMACRO BIN-NEXT-COMMAND (&REST ARGS)
  224.   `(FUNCALL *BIN-NEXT-COMMAND-FUNCTION* . ,ARGS))
  225.  
  226. (DEFMACRO LOADING-BIN-FILE ((STREAM NEXT-COMMAND-FUNCTION SKIP-READING-PROPERTY-LIST)
  227.                 &BODY BODY)
  228.   `(LET* ((*BIN-NEXT-COMMAND-FUNCTION* ,NEXT-COMMAND-FUNCTION)
  229.       (*BIN-LOAD-INDEX* 0)
  230.       (*FILE-BIN-VERSION* 0)
  231.       (*ROW-MAJOR-ORDER?* *ROW-MAJOR-ORDER?*))
  232.        (USING-RESOURCE (*BIN-LOAD-TABLE* BIN-LOAD-TABLE)
  233.      (BIN-LOAD-START ,STREAM ,SKIP-READING-PROPERTY-LIST)
  234.        (PROGN . ,BODY))))
  235.  
  236. ;;;Load command definitions...
  237. ;;;There are three types of commands
  238.  
  239. (DEFMACRO DEFINE-BIN-COMMAND-OP (OP-NAME DEFINING-FUNCTION TABLE FUNCTION-PREFIX ARGLIST
  240.                  &BODY DEFINITION)
  241.   (LET ((FUNCTION-NAME (LET (#-3600 (DEFAULT-CONS-AREA WORKING-STORAGE-AREA))
  242.              (INTERN (STRING-APPEND FUNCTION-PREFIX OP-NAME)))))
  243.     `(PROGN 'COMPILE
  244.        (SETF (BIN-OP-DISPATCH ,TABLE (LDB %%BIN-OP-LOW ,OP-NAME)) ',FUNCTION-NAME)
  245.        (RECORD-SOURCE-FILE-NAME ',OP-NAME ',DEFINING-FUNCTION)
  246.        (LOCAL-DECLARE ((SYS:FUNCTION-PARENT ,OP-NAME ,DEFINING-FUNCTION))
  247.      (DEFUN ,FUNCTION-NAME ,ARGLIST . ,DEFINITION)))))
  248.  
  249. ;;; A command that may return a value, but does not store it in the table
  250. (DEFMACRO DEFINE-LOAD-COMMAND (OP-NAME ARGLIST &BODY BODY)
  251.   `(DEFINE-BIN-COMMAND-OP ,OP-NAME DEFINE-LOAD-COMMAND
  252.               *BIN-OP-LOAD-COMMAND-TABLE* "LOAD-" ,ARGLIST
  253.      . ,BODY))
  254.  
  255. ;;; A command that does not return a value at all
  256. (DEFMACRO DEFINE-LOAD-COMMAND-FOR-EFFECT (OP-NAME ARGLIST &BODY BODY)
  257.   `(DEFINE-BIN-COMMAND-OP ,OP-NAME DEFINE-LOAD-COMMAND-FOR-EFFECT
  258.               *BIN-OP-LOAD-COMMAND-TABLE* "LOAD-" ,ARGLIST
  259.      ,@BODY
  260.      *NO-VALUE-MARKER*))
  261.  
  262. ;;; A command that returns a value stored in the next slot in the table
  263. (DEFMACRO DEFINE-LOAD-COMMAND-FOR-VALUE (OP-NAME ARGLIST &BODY BODY)
  264.   `(DEFINE-BIN-COMMAND-OP ,OP-NAME DEFINE-LOAD-COMMAND-FOR-VALUE
  265.               *BIN-OP-LOAD-COMMAND-TABLE* "LOAD-" ,ARGLIST
  266.      (ENTER-BIN-LOAD-TABLE (PROGN . ,BODY))))
  267.  
  268. (DEFMACRO ENTER-BIN-LOAD-TABLE (VALUE)
  269.   `(LET ((.INDEX. *BIN-LOAD-INDEX*))
  270.      (INCF *BIN-LOAD-INDEX*)
  271.      (ENTER-BIN-LOAD-TABLE-INTERNAL ,VALUE .INDEX.)))
  272.  
  273. ;;; Loading Loading stuff common to all boxes
  274. (DEFMACRO LOAD-VANILLA-BOX ((STREAM) &BODY BODY)
  275.   `(LET* ((NAME (BIN-NEXT-VALUE ,STREAM))
  276.       (DISPLAY-LIST (BIN-NEXT-VALUE ,STREAM))
  277.       ;; these next three lines are for compatibility with the turtle box version of BOXER
  278.       (INITIAL-ENVIRONMENT (BIN-NEXT-VALUE ,STREAM))
  279.       (TURTLE-BINDING-PAIR (ASSQ '%TURTLE INITIAL-ENVIRONMENT))
  280.       (ENVIRONMENT (IF (NOT-NULL TURTLE-BINDING-PAIR)
  281.                (PUSH (CONS *EXPORTING-BOX-MARKER* (CDR TURTLE-BINDING-PAIR))
  282.                  INITIAL-ENVIRONMENT)
  283.                INITIAL-ENVIRONMENT))
  284.       ;; leave this here for non local-library files (< version 4.0)
  285.       ;; I'm changing this cause UNIX file streams are losing on :TYIPEEK
  286.       (local-library (progn (if (not (= (send ,stream :tyi)
  287.                         BIN-OP-LL-BOX-PRESCENCE-MARKER))
  288.                     (cl:error "There should be a local library marker here"))
  289.                 (bin-next-value ,stream)))
  290. ;      (LOCAL-LIBRARY (WHEN (= (SEND STREAM :TYIPEEK) BIN-OP-LL-BOX-PRESCENCE-MARKER)
  291. ;               (SEND STREAM :TYI)
  292. ;               ;; a local library HAS been dumped so return it or else NIL
  293. ;               ;; REMOVE this SOON !!!!
  294. ;               (BIN-NEXT-VALUE ,STREAM)))
  295.       )
  296.      (PROGN . ,BODY)))
  297.  
  298.  
  299. ;;; Rel 4.5 lossage in not having a KEYWORD package.  We will dump names with colon prefixes
  300. ;;; into the KEYWORD package and on loading (in rel 4.5) put them back into the USER package
  301. ;;; so that files will be rel 5.0 compatible with this crock for rel 4.5
  302.  
  303. #+rel4
  304. (package-declare keyword global 100)
  305.  
  306. #+rel4
  307. (defvar pkg-keyword-package (pkg-find-package 'keyword))
  308.